home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d5 / willy.arc / WILLY.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-06-11  |  15.4 KB  |  609 lines
  1. program willy;
  2.  
  3. type namest = string[20];
  4.      scorec = record
  5.                 sc:integer;
  6.                 na:namest;
  7.               end;
  8.  
  9. var n,m,score,scrnum,balls,pcdlay,
  10.     oldx,oldy,worms,wx,wy,wc,
  11.     scount,bcount,bonus,vx,vy,updown,
  12.     wxdir,wydir,jcount,lfrt,
  13.     color1,color2,color3,color4,
  14.     color5,color6,maxballs     : integer;
  15.     ballx,bally,ballc,balld    : array[1..9] of integer;
  16.     hiscoreP,hiscoreT          : array[1..10] of integer;
  17.     hinameP,hinameT            : array[1..10] of namest;
  18.     startxy                    : array[1..64,1..2] of byte;
  19.     name                       : namest;
  20.     chrset                     : array[1..1024] of byte;
  21.     screendata                 : array[1..9,1..40,1..24] of byte;
  22.     startx,starty              : array[1..8] of byte;
  23.     screen                     : array[1..40,1..24] of byte;
  24.     jflag,stop,win,lose,
  25.     soundflag                  : boolean;
  26.     key                        : string[1];
  27.     tableofs,tableseg          : integer;
  28.     dfile                      : file;
  29.     scorefile                  : file of scorec;
  30.     element                    : scorec;
  31.  
  32. procedure setup;
  33.  
  34. var x,y,z:integer;
  35.     q:char;
  36.  
  37. begin
  38.   clrscr;
  39.   textcolor(white);
  40.   writeln('                          Willy the Worm --- Ver. 2.0');
  41.   writeln('                           by Alan Farmer, June 1985');
  42.   writeln;
  43.   writeln;
  44.   writeln('          This is a user-supported program.   Feel free to make copies');
  45.   writeln('          and pass them out, but  please  do not sell them.  Donations');
  46.   writeln('          of about $10 would be greatly appreciated.  Please send your');
  47.   writeln('          questions, comments, high scores, improved game screens, and');
  48.   writeln('          DONATIONS to:');
  49.   writeln;
  50.   writeln('                           Alan Farmer');
  51.   writeln('                           2743 McElroy Drive');
  52.   writeln('                           Charlottesville, Va  22903');
  53.   tableofs:=memw[$0000:$007c];
  54.   tableseg:=memw[$0000:$007e];
  55.   memw[$0000:$007c]:=ofs(chrset[1]);
  56.   memw[$0000:$007e]:=seg(chrset[1]);
  57.   assign(dfile,'WILLY.CHR');
  58.   reset(dfile);
  59.   blockread(dfile,chrset,8);
  60.   close(dfile);
  61.   assign(dfile,'WILLY.DAT');
  62.   reset(dfile);
  63.   blockread(dfile,screendata,60);
  64.   blockread(dfile,startxy,1);
  65.   close(dfile);
  66.   assign(scorefile,'WILLY.SCR');
  67.   reset(scorefile);
  68.   for x:=1 to 10 do
  69.     begin
  70.       read(scorefile,element);
  71.       hiscoreP[x]:=element.sc;
  72.       hinameP[x]:=element.na;
  73.     end;
  74.   close(scorefile);
  75.   if mem[$f000:$fffe]=$fd then pcdlay:=0 else pcdlay:=25;
  76.   writeln;
  77.   writeln;
  78.   writeln;
  79.   write('                         Are you using a color monitor?  ');
  80.   repeat until keypressed;
  81.   read(kbd,q);
  82.   if upcase(q)='Y' then writeln('Yes') else writeln('No');
  83.   if upcase(q)='Y' then
  84.     begin
  85.       color1:=blue;
  86.       color2:=red;
  87.       color3:=yellow;
  88.       color4:=yellow;
  89.       color5:=lightcyan;
  90.     end
  91.   else
  92.     begin;
  93.       color1:=black;
  94.       color2:=lightgray;
  95.       color3:=lightgray;
  96.       color4:=white;
  97.       color5:=white;
  98.     end;
  99.   write('                         Do you want sound effects?      ');
  100.   repeat until keypressed;
  101.   read(kbd,q);
  102.   if upcase(q)='Y' then writeln('Yes') else writeln('No');
  103.   if upcase(q)='Y' then soundflag:=true else soundflag:=false;
  104.   for m:=1 to 10 do
  105.     begin
  106.       hiscoreT[m]:=0;
  107.       hinameT[m]:='';
  108.     end;
  109.   graphcolormode; palette(1); textcolor(3); graphbackground(color1);
  110.   gotoxy(13,4); writeln('Willy the Worm'); writeln; writeln;
  111.   writeln('Meet Willy the Worm ',chr(128),'.  Willy is a fun-');
  112.   writeln('loving invertebrate who likes to climb');
  113.   writeln('ladders ',chr(131),', bounce on springs ',chr(133),' ',chr(134));
  114.   writeln('and find his presents ',chr(130),'.  But more');
  115.   writeln('than anything, Willy loves to ring');
  116.   writeln('bells ',chr(136),'!');
  117.   writeln;
  118.   writeln('You can press the arrow keys ',chr(24),' ',chr(25),' ',chr(26),' ',
  119.     chr(27));
  120.   writeln('to make Willy run and climb, or the');
  121.   writeln('space bar to make him jump. Anything');
  122.   writeln('else will make Willy stop and wait.');
  123.   writeln;
  124.   writeln('Good luck, and don''t let Willy step on');
  125.   writeln('a tack ',chr(132),'!');
  126.   writeln;
  127.   write('Press Enter ',chr(17),chr(217),' to start the game...');
  128.   readln;
  129. end;
  130.  
  131. procedure exit;
  132.  
  133. begin
  134.   memw[$0000:$007c]:=tableofs;
  135.   memw[$0000:$007e]:=tableseg;
  136.   assign(scorefile,'WILLY.SCR');
  137.   rewrite(scorefile);
  138.   for m:=1 to 10 do
  139.     begin
  140.       element.sc:=hiscoreP[m];
  141.       element.na:=hinameP[m];
  142.       write(scorefile,element);
  143.     end;
  144.   close(scorefile);
  145.   textmode;
  146.   clrscr;
  147.   halt;
  148. end;
  149.  
  150. procedure winsound;
  151.  
  152. begin
  153.   gotoxy(13,10);
  154.   write('** Bonus ',bonus,' **');
  155.   if soundflag then for m:=1 to 5 do
  156.     begin
  157.       sound(2000);
  158.       delay(45);
  159.       nosound;
  160.       delay(30)
  161.     end;
  162.   delay(500)
  163. end;
  164.  
  165. procedure losesound;
  166.  
  167. begin
  168.   if soundflag then
  169.     begin
  170.       for m:=1 to 5 do
  171.         begin
  172.           sound(220);
  173.           nosound;
  174.           delay(m)
  175.         end;
  176.       for m:=12 downto 1 do
  177.         begin
  178.           sound(2000);
  179.           nosound;
  180.           delay(m div 2)
  181.         end;
  182.     end;
  183.   for m:=1 to 20 do
  184.     begin
  185.       graphbackground(color2);
  186.       delay(pcdlay);
  187.       graphbackground(color3);
  188.       delay(pcdlay);
  189.     end;
  190.   graphbackground(color1);
  191. end;
  192.  
  193. procedure getscreen;
  194.  
  195. var box : boolean;
  196.  
  197. begin
  198.   graphcolormode; palette(1); textcolor(3); graphbackground(color1);
  199.   box:=false;
  200.   for n:=1 to 24 do
  201.     for m:=1 to 40 do
  202.       begin
  203.         screen[m,n]:=screendata[scrnum,m,n];
  204.         gotoxy(m,n);
  205.         write(char(screen[m,n]));
  206.         if (screen[m,n]=254) and (not box) then
  207.           begin
  208.             box:=true;
  209.             vx:=m;
  210.             vy:=n;
  211.           end;
  212.       end;
  213.   wx:=startxy[scrnum,1];
  214.   wy:=startxy[scrnum,2];
  215.   wc:=32;
  216.   gotoxy(3,25);
  217.   write('Score ',score:6,'  Bonus 1000  Worms ');
  218.   for n:=1 to worms-1 do write(chr(129))
  219. end;
  220.  
  221. procedure addpoints(a : integer; b : boolean);
  222.  
  223. var c : integer;
  224.  
  225. begin
  226.   score:=score+a;
  227.   gotoxy(9,25);
  228.   write(score:6);
  229.   if b and soundflag then
  230.     begin
  231.       sound(1200);
  232.       delay(10);
  233.       sound(1660);
  234.       delay(10);
  235.       nosound
  236.     end;
  237.   scount:=scount+a;
  238.   if scount>3000 then
  239.     begin
  240.       scount:=scount-3000;
  241.       if soundflag then for c:=500 to 1500 do sound(c);
  242.       nosound;
  243.       worms:=worms+1;
  244.       gotoxy(35,25);
  245.       if worms>6 then
  246.         begin
  247.           for c:=1 to 5 do write(chr(129));
  248.           write('+');
  249.         end
  250.       else for c:=1 to worms-1 do write(chr(129))
  251.     end
  252. end;
  253.  
  254. procedure movewilly;
  255.  
  256. var z : integer;
  257.  
  258. begin
  259.   delay(pcdlay);
  260.   z:=memw[$40:28];
  261.   z:=z-2;
  262.   if z<30 then z:=60;
  263.   key:=chr(mem[$40:z+1]);
  264.   case key of
  265.     #1  :  exit;
  266.     'H' :  updown:=-1;
  267.     'P' :  updown:=1;
  268.     '9' :  if (jcount=0) and (screen[wx,wy+1]>=179) and
  269.              (screen[wx,wy+1]<=218) and (screen[wx,wy]<>131) then
  270.                begin
  271.                  updown:=0;
  272.                  jcount:=1;
  273.                  jflag:=true;
  274.                end;
  275.     'K' :  begin
  276.              updown:=0;
  277.              lfrt:=-1;
  278.            end;
  279.     'M' :  begin
  280.              updown:=0;
  281.              lfrt:=1;
  282.            end;
  283.     #$ff:  begin end;
  284.       else
  285.         begin
  286.           updown:=0;
  287.           lfrt:=0;
  288.         end
  289.     end;
  290.   memw[$40:z]:=255 shl 8;
  291.   oldx:=wx; oldy:=wy;
  292.   wxdir:=lfrt;
  293.   wydir:=0;
  294.   if jcount>0 then
  295.     begin
  296.       case jcount of
  297.         1 : wydir:=-1;
  298.         2 : wydir:=-1;
  299.         3 : wydir:=-1;
  300.         4 : wydir:=0;
  301.         5 : wydir:=1;
  302.         6 : wydir:=1;
  303.         7 : wydir:=1;
  304.       end;
  305.     end;
  306.   if (jcount=0) and (screen[wx,wy]<>131) and ((screen[wx,wy+1]<179)
  307.     or (screen[wx,wy+1]>218)) then
  308.       begin
  309.         wxdir:=0;
  310.         wydir:=1
  311.       end;
  312.   if (updown<>0) and (jcount=0) and (screen[wx,wy]=131) then
  313.     begin
  314.       lfrt:=0;
  315.       if updown<>0 then wxdir:=0;
  316.       wydir:=0;
  317.       if (updown=-1) and (wy>1) then
  318.         if screen[wx,wy-1]=131 then wydir:=-1;
  319.       if (updown=1) and (wy<24) then
  320.         if (screen[wx,wy+1]<179) or (screen[wx,wy+1]>218) then wydir:=1;
  321.     end;
  322.   if (jcount>0) and (screen[wx,wy]=131) then
  323.     begin
  324.       jcount:=0;
  325.       lfrt:=0;
  326.       wxdir:=0;
  327.       wydir:=0
  328.     end;
  329.   if (jcount=0) and (lfrt=-1) then
  330.     if wx-1<1 then lfrt:=0
  331.   else if (screen[wx-1,wy]>=179) and (screen[wx-1,wy]<=218) then lfrt:=0;
  332.   if (jcount=0) and (lfrt=1) then
  333.     if wx+1>40 then lfrt:=0
  334.   else if (screen[wx+1,wy]>=179) and (screen[wx+1,wy]<=218) then lfrt:=0;
  335.   if (wx+wxdir<1) or (wx+wxdir>40) then wxdir:=0;
  336.   if (wy+wydir<1) or (wy+wydir>24) then wydir:=0;
  337.   if jcount>0 then jcount:=(jcount+1) mod 8;
  338.   if (wxdir<>0) and (screen[wx,wy+1]=196) then
  339.     begin
  340.       screen[wx,wy+1]:=32;
  341.       gotoxy(wx,wy+1);
  342.       write(' ')
  343.     end;
  344.   if (screen[wx+wxdir,wy+wydir]<179) or (screen[wx+wxdir,wy+wydir]>218) then
  345.     begin
  346.       wx:=wx+wxdir;
  347.       wy:=wy+wydir
  348.     end
  349.   else wydir:=0;
  350.   if (wydir<>0) and soundflag then sound((25-wy)*100);
  351.   gotoxy(oldx,oldy); write(chr(wc));
  352.   wc:=screen[wx,wy]; gotoxy(wx,wy);
  353.   if lfrt=1 then write(chr(128)) else write(chr(129));
  354.   nosound;
  355.   if jcount=0 then jflag:=false;
  356.   if wc=132 then lose:=true;
  357.   if wc=133 then
  358.     begin
  359.       jcount:=1;
  360.       jflag:=true;
  361.     end;
  362.   if wc=134 then lfrt:=-lfrt;
  363.   if wc=136 then win:=true;
  364.   if wc=130 then
  365.     begin
  366.       wc:=32;
  367.       screen[wx,wy]:=wc;
  368.       addpoints(100,true);
  369.     end;
  370. end;
  371.  
  372. procedure moveballs;
  373.  
  374. var u,v : integer;
  375.  
  376. begin
  377.   if (random<0.1) and (balls<maxballs) then
  378.     begin
  379.       balls:=balls+1;
  380.       ballx[balls]:=vx;
  381.       bally[balls]:=vy;
  382.       balld[balls]:=0;
  383.       ballc[balls]:=254
  384.     end;
  385.   m:=(6-balls)*12;
  386.   if m>0 then delay(m);
  387.   for u:=1 to balls do
  388.     begin
  389.       gotoxy(ballx[u],bally[u]);
  390.       write(char(ballc[u]));
  391.       if balld[u]=0 then
  392.         begin
  393.           v:=screen[ballx[u],bally[u]+1];
  394.           if ((v<179) or (v>218)) and (bally[u]<24) then bally[u]:=bally[u]+1
  395.           else if random<0.5 then balld[u]:=-1 else balld[u]:=1
  396.         end;
  397.      if (balld[u]=-1) and (ballx[u]=1) then balld[u]:=1;
  398.      if (balld[u]=1) and (ballx[u]=40) then balld[u]:=-1;
  399.      if balld[u]=-1 then
  400.         begin
  401.           v:=screen[ballx[u]-1,bally[u]];
  402.           if (v>=179) and (v<=218) then balld[u]:=1
  403.           else ballx[u]:=ballx[u]-1
  404.         end;
  405.       if balld[u]=1 then
  406.         begin
  407.           v:=screen[ballx[u]+1,bally[u]];
  408.           if (v>=179) and (v<=218) then balld[u]:=-1
  409.           else ballx[u]:=ballx[u]+1
  410.         end;
  411.       v:=screen[ballx[u],bally[u]+1];
  412.       if (v<179) or (v>218) then balld[u]:=0;
  413.       ballc[u]:=screen[ballx[u],bally[u]];
  414.       if ballc[u]=254 then
  415.         begin
  416.           ballx[u]:=vx;
  417.           bally[u]:=vy;
  418.           balld[u]:=0
  419.         end;
  420.       gotoxy(ballx[u],bally[u]);
  421.       write(char(135));
  422.       if (balld[u]=-1) and (ballx[u]=1) then balld[u]:=1;
  423.       if (balld[u]=1) and (ballx[u]=40) then balld[u]:=-1;
  424.     end
  425. end;
  426.  
  427. procedure collision;
  428.  
  429.   procedure jumped_one;
  430.  
  431.   begin
  432.     addpoints(20,true);
  433.     jflag:=false
  434.   end;
  435.  
  436. begin
  437.   for m:=1 to balls do
  438.     begin
  439.       if jflag then case jcount of
  440.         2,7 : if (ballx[m]=wx) and (bally[m]=wy+1) then jumped_one;
  441.         3,6 : if (ballx[m]=wx) and (bally[m]=wy+2) then jumped_one;
  442.         4,5 : if (ballx[m]=wx) and (bally[m]=wy+3) then jumped_one;
  443.       end;
  444.       if (ballx[m]=wx) and (bally[m]=wy) then lose:=true;
  445.     end;
  446. end;
  447.  
  448. procedure playgame;
  449.  
  450. begin
  451.   scrnum:=1;
  452.   score:=0;
  453.   scount:=0;
  454.   worms:=5;
  455.   maxballs:=5;
  456.   repeat
  457.     balls:=0;    bonus:=1000;  bcount:=0;
  458.     lfrt:=0;     updown:=0;    jcount:=0;
  459.     lose:=false; win:=false;
  460.     getscreen;
  461.     repeat
  462.       bcount:=bcount+1;
  463.       if (bcount mod 15=0) then
  464.         begin
  465.           bonus:=bonus-10;
  466.           gotoxy(23,25);
  467.           write(bonus:4)
  468.         end;
  469.       if bonus=0 then lose:=true;
  470.       movewilly;
  471.       collision;
  472.       if not lose then moveballs;
  473.       if not lose then collision;
  474.     until win or lose;
  475.     if win then
  476.       begin
  477.         addpoints(bonus,false);
  478.         scrnum:=scrnum+1;
  479.         if scrnum=9 then
  480.           begin
  481.             scrnum:=1;
  482.             maxballs:=maxballs+2;
  483.             if maxballs>9 then maxballs:=9;
  484.           end;
  485.         winsound
  486.       end;
  487.     if lose then
  488.       begin
  489.         worms:=worms-1;
  490.         losesound;
  491.       end;
  492.   until worms=0
  493. end;
  494.  
  495. procedure showscores;
  496.  
  497. var q:char;
  498.     a,b:integer;
  499.  
  500. begin
  501.   a:=-1; b:=-1;
  502.   textmode(c40);
  503.   textbackground(color1);
  504.   textcolor(white);
  505.   clrscr;
  506.   if score>hiscoreP[10] then writeln('You''re an Official Nightcrawler!')
  507.     else if score>hiscoreT[10] then writeln('You''re a Daily Pinworm!');
  508.   writeln;
  509.   writeln('Your score for this game is ',score,'...');
  510.   if score<1000 then writeln('Didn''t you even read the instructions?')
  511.   else if score<2000 then writeln('If you can''t say anything nice... ')
  512.   else if score<3000 then writeln('Okay.  Maybe you''re not so bad after    all.')
  513.   else if score<4000 then writeln('Wow!  Absolutely mediocre!')
  514.   else if score<5000 then writeln('Pretty darn good, for a vertebrate!')
  515.   else if score<6000 then writeln('Well done!  Do you often eat garbage?')
  516.   else writeln('Absolutely fantastic!  You should       consider a career as an earthworm!');
  517.   if score>hiscoreT[10] then
  518.     begin
  519.       writeln;
  520.       write('Enter your name >> ');
  521.       readln(name);
  522.       m:=1;
  523.       while (m<10) and (score<hiscoreT[m]) do m:=m+1;
  524.       a:=m+13;
  525.       for n:=10 downto m+1 do
  526.         begin
  527.           hiscoreT[n]:=hiscoreT[n-1];
  528.           hinameT[n]:=hinameT[n-1];
  529.         end;
  530.       hiscoreT[m]:=score;
  531.       hinameT[m]:=name;
  532.       if score>hiscoreP[10] then
  533.         begin
  534.           m:=1;
  535.           while score<hiscoreP[m] do m:=m+1;
  536.           b:=m+1;
  537.           for n:=10 downto m+1 do
  538.             begin
  539.               hiscoreP[n]:=hiscoreP[n-1];
  540.               hinameP[n]:=hinameP[n-1];
  541.             end;
  542.           hiscoreP[m]:=score;
  543.           hinameP[m]:=name;
  544.         end;
  545.     end
  546.   else
  547.     begin
  548.       writeln;
  549.       write('Press any key... ');
  550.       repeat until keypressed
  551.     end;
  552.   clrscr;
  553.   window(6,2,35,11);
  554.   textbackground(black);
  555.   clrscr;
  556.   window(6,14,35,23);
  557.   clrscr;
  558.   window(1,1,40,25);
  559.   textcolor(color4);
  560.   textbackground(color1);
  561.   gotoxy(10,1);
  562.   write('All-Time Nightcrawlers');
  563.   textcolor(color5);
  564.   gotoxy(10,13);
  565.   write('Today''s Best Pinworms');
  566.   textcolor(color4);
  567.   textbackground(black);
  568.   for m:=1 to 10 do
  569.     begin
  570.       gotoxy(6,m+1);
  571.       write(m:2,' ',hiscoreP[m]:6,' ',hinameP[m]);
  572.     end;
  573.   textcolor(color5);
  574.   for m:=1 to 10 do
  575.     begin
  576.       gotoxy(6,m+13);
  577.       write(m:2,' ',hiscoreT[m]:6,' ',hinameT[m]);
  578.     end;
  579.   textcolor(white+blink);
  580.   textbackground(color1);
  581.   if a>0 then
  582.     begin
  583.       gotoxy(5,a);
  584.       write(chr(26));
  585.     end;
  586.   if b>0 then
  587.     begin
  588.       gotoxy(5,b);
  589.       write(chr(26));
  590.     end;
  591.   textcolor(white);
  592.   gotoxy(2,25);
  593.   write('Hit a key to play again or ESC to exit');
  594.   repeat until keypressed;
  595.   read(kbd,q);
  596.   if keypressed then read(kbd,q);
  597.   if q=#27 then stop:=true else stop:=false;
  598. end;
  599.  
  600. begin
  601.   randomize;
  602.   setup;
  603.   repeat
  604.     playgame;
  605.     showscores;
  606.   until stop;
  607.   exit
  608. end.
  609.